home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / color.swg / 0013_Palette Control #2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  4.2 KB  |  215 lines
  1. Unit palette;
  2. {$O+}
  3. Interface
  4.  
  5. Uses Dos,Crt;
  6.  
  7. Procedure Set_palette(slot:Word; sred,sgreen,sblue : Byte);
  8. Procedure Get_palette(Var slot,gred,ggreen,gblue : Byte);
  9. Procedure fade_in(dly : Word ; dvsr : Byte);   {Delay (ms),divisor (10-64)}
  10. Procedure fade_out(dly : Word ; dvsr : Byte);
  11. Procedure restore_palette;
  12. Procedure swap_color(first,last:Byte);
  13. Function VGASystem: Boolean;
  14. Procedure remap;
  15. Procedure restoremap;
  16.  
  17. Const
  18.   sl     : Array[0..15] of Byte =(0,1,2,3,4,5,20,7,56,57,58,59,60,61,62,63);
  19.   v_red  : Array[0..15] of Byte =(0,0,0,0,42,42,42,42,21,21,21,21,63,63,63,63);
  20.   v_green: Array[0..15] of Byte =(0,0,42,42,0,0,21,42,21,21,63,63,21,21,63,63);
  21.   v_blue : Array[0..15] of Byte =(0,42,0,42,0,42,0,42,21,63,21,63,21,63,21,63);
  22.  
  23. Var
  24.   s_red, s_green, s_blue : Array[0..15] of Real;
  25.  
  26. Implementation
  27.  
  28. Procedure disable_refresh;
  29. Var
  30.   regs : Registers;
  31. begin
  32.   With regs do
  33.   begin
  34.     AH:=$12;
  35.     BL:=$36;
  36.     AL:=$01;
  37.   end;
  38.   Intr($10,regs);
  39. end;
  40.  
  41. Procedure enable_refresh;
  42. Var
  43.   regs : Registers;
  44. begin
  45.   With regs do
  46.   begin
  47.     AH:=$12;
  48.     BL:=$36;
  49.     AL:=$00;
  50.   end;
  51.   Intr($10,regs);
  52. end;
  53.  
  54. Function VGASystem: Boolean;
  55. {}
  56. Var  Regs : Registers;
  57. begin
  58.   With Regs do
  59.   begin
  60.     Ax := $1C00;
  61.     Cx := 7;
  62.     Intr($10,Regs);
  63.     If Al = $1C then  {VGA}
  64.     begin
  65.       VGASystem := True;
  66.       Exit;
  67.     end;
  68.     Ax := $1200;
  69.     Bl := $32;
  70.     Intr($10,Regs);
  71.     If Al = $12 then {MCGA}
  72.     begin
  73.       VGASystem := True;
  74.       Exit;
  75.     end;
  76.   end; {with}
  77. end; {of func NoSnowSystem}
  78.  
  79. Procedure remap;
  80. Var
  81.   regs : Registers;
  82.   idx  : Byte;
  83. begin
  84.   if VGASystem then
  85.   begin
  86.     With regs do
  87.     begin
  88.       AL:=0;
  89.       AH:=11;
  90.     end;
  91.     For idx:=0 to 15 do
  92.     begin
  93.       regs.BH:=idx;
  94.       regs.BL:=idx;
  95.       Intr($10,Regs);
  96.     end;
  97.   end;
  98. end;
  99.  
  100. Procedure restoremap;
  101. Var
  102.   regs : Registers;
  103.   idx  : Byte;
  104. begin
  105.   if VGASystem then
  106.   begin
  107.     With regs do
  108.     begin
  109.       AL:=0;
  110.       AH:=11;
  111.     end;
  112.     For idx:=0 to 15 do
  113.     begin
  114.       regs.BH:=sl[idx];
  115.       regs.BL:=idx;
  116.       Intr($10,Regs);
  117.     end;
  118.   end;
  119. end;
  120.  
  121. Procedure Set_palette(slot:Word; sred,sgreen,sblue : Byte);
  122. Var
  123.   regs : Registers;
  124. begin
  125.   With regs do
  126.   begin
  127.     AL:=$10;
  128.     AH:=$10;
  129.     BX:=slot;
  130.     DH:=sred;
  131.     CH:=sgreen;
  132.     CL:=sblue;
  133.   end;
  134.   Intr($10,Regs);
  135. end;
  136.  
  137. Procedure Get_palette(Var slot,gred,ggreen,gblue : Byte);
  138. Var
  139.   regs : Registers;
  140. begin
  141.   With regs do
  142.   begin
  143.     AL:=21;
  144.     AH:=16;
  145.     BX:=slot;
  146.   end;
  147.   Intr($10,Regs);
  148.   With regs do
  149.   begin
  150.     gred:=DH;
  151.     ggreen:=CH;
  152.     gblue:=CL;
  153.   end;
  154. end;
  155.  
  156. Procedure restore_palette;
  157. Var index:Byte;
  158. begin
  159.   For index:=0 to 15 do
  160.       set_palette(sl[index],v_red[index],v_green[index],v_blue[index]);
  161. end;
  162. Procedure fade_out(dly : Word ; dvsr : Byte);
  163. Var index,idx : Byte;
  164. begin
  165.   For index:=0 to 15 do
  166.   begin
  167.     s_red[index]:=v_red[index];
  168.     s_green[index]:=v_green[index];
  169.     s_blue[index]:=v_blue[index];
  170.   end;
  171.   For idx:=1 to dvsr do
  172.   begin
  173.     For index:=0 to 15 do
  174.     begin
  175.       set_palette(sl[index],trunc(s_red[index]),trunc(s_green[index]),trunc(s_blue[index]));
  176.       s_red[index]:=s_red[index]-(v_red[index]/dvsr);
  177.       s_green[index]:=s_green[index]-(v_green[index]/dvsr);
  178.       s_blue[index]:=s_blue[index]-(v_blue[index]/dvsr);
  179.     end;
  180.     Delay(dly)
  181.   end;
  182. end;
  183.  
  184. Procedure fade_in(dly : Word ; dvsr : Byte);
  185. Var index,idx2:Byte;
  186. begin
  187.   FillChar(s_red,Sizeof(S_red),#0);
  188.   FillChar(s_green,Sizeof(S_green),#0);
  189.   FillChar(s_blue,Sizeof(s_blue),#0);
  190.   For idx2:=1 to dvsr do
  191.   begin
  192.     For index:=0 to 15 do
  193.     begin
  194.       set_palette(sl[index],trunc(s_red[index]),trunc(s_green[index]),trunc(s_blue[index]));
  195.       s_red[index]:=s_red[index]+(v_red[index]/dvsr);
  196.       s_green[index]:=s_green[index]+(v_green[index]/dvsr);
  197.       s_blue[index]:=s_blue[index]+(v_blue[index]/dvsr);
  198.     end;
  199.   Delay(dly);
  200.   end;
  201. end;
  202.  
  203. Procedure swap_color(first,last:Byte);
  204. Var f1,f2,f3,l1,l2,l3:Byte;
  205. begin
  206.   Get_Palette(sl[first],f1,f2,f3);
  207.   Get_Palette(sl[last],l1,l2,l3);
  208.   Set_Palette(sl[first],l1,l2,l3);
  209.   Set_Palette(sl[last],f1,f2,f3);
  210. end;
  211.  
  212. begin
  213.   restoremap;
  214. end.
  215.